home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
DB_CLIPP
/
0669.ZIP
/
MENUS.PRG
< prev
next >
Wrap
Text File
|
1987-03-06
|
12KB
|
308 lines
****************************************************************************
* The following demo shows how the function PROMPTER() can be used *
* instead of Clipper's built-in PROMPT/MESSAGE/MENU commands. *
* Advantages include: *
* - continuour wrap-around of the highlight bar *
* - no conflict with GET/READ since INKEY() is used (PROMPTER() only) *
* - no conflict with function keys *
* - F1 key can be reassigned while function is active *
* - horizontal prompts are easily spaced with one parameter *
* - easy to change between horiz & vert prompting *
* - easy to change spacing between prompts *
* *
* In this example, the user can also toggle between menu types *
* (highlighted prompts or numbered choices) by hitting F2. *
* *
* The example uses Tom Rettig's external call CURSOR to turn the *
* cursor on and off; if you do not have TR.LIB, comment out the lines *
* which have the word CURSOR. Otherwise, this file can be compiled and *
* linked as is. *
* *
* Author: C&E Consulting *
* 6 Pebblecreek Court *
* Taylors, SC 29687 *
* (803) 268-3341 *
* *
* CompuServe - 76137,252 *
* The Source - NA2112 *
* *
* Plug: C&E Consulting provides custom program development in a *
* variety of languages, as well as training and hardware *
* recommendations. *
* *
* Updates and other utilities can be obtained by sending *
* an appropriate contribution to the address above. *
* *
* *
****************************************************************************
* Initialize prompts and messages in arrays
DECLARE prompts[10],messages[10]
prompts[1] ='One '
prompts[2] ='Two '
prompts[3] ='Three'
prompts[4] ='Four '
prompts[5] ='Five '
prompts[6] ='Six '
prompts[7] ='Seven'
prompts[8] ='Eight'
prompts[9] ='Nine '
prompts[10]='Ten '
FOR n=1 TO 10
messages[n]='Message for prompt '+STR(n,2)
NEXT
STORE .F. TO menu_num,menu_vert,mreset
IF ISCOLOR()
color1='g/n,w/r'
color2='w/r'
ELSE
color1='w/n,n/w'
color2='n/w'
ENDIF
SET COLOR TO &color1
** DO SETFKEY WITH 1,'HELP' && set F1 Key to Help
DO SETFKEY WITH 2,'f_key2' && set F2 Key to toggle menu types
DO SETFKEY WITH 3,'f_key3' && set F3 Key to toggle vert/horiz
CLEAR
@ 1,0 SAY 'MENU SAMPLER - F2-bar/number F3-vert/horiz ESC-Quit'
@ 2,0 SAY 'Copyright (c) 1987 C&E Consulting, Taylors, SC'
DO WHILE .T.
@ 3,0 CLEAR TO 23,79
IF menu_vert
IF menu_num
maction=PROMPTNM(8,8,10) && vert numbered menus
ELSE
maction=PROMPTER(8,8,10,color1,color2,3) && vert highlight menus
ENDIF
ELSE
IF menu_num
maction=PROMPTNM(8,0,10,.T.,10) && horiz numbered menus
ELSE
maction=PROMPTER(8,0,10,color1,color2,3,.T.,7) && horiz highlight menus
ENDIF
ENDIF
IF mreset && user has hit a menu toggle
mreset=.F.
LOOP
ENDIF
IF maction=0 && Esc or 0 key hit
CLEAR
QUIT
ENDIF
@ 24,0 SAY prompts[maction]+' chosen...' && result (put DO prgs here)
ENDDO
PROCEDURE SETFKEY
* This procedure sets function keys - allows remapping by user
PARAMETER funckey,procname
PRIVATE fkey,fval
fval=IIF(-funckey+1=0,'28',STR(-funckey+1,2)) && translate Fkey# to Inkey#
fkey=LTRIM(STR(funckey,2))
IF TYPE("procname")="U" && if procedure name not passed
f_key&fkey='Undefined'
SET KEY &fval TO
ELSE
f_key&fkey=procname
SET KEY &fval TO &procname
ENDIF
RETURN
PROCEDURE f_key2 && Function key F2 toggles menu type
menu_num=IIF(menu_num=.T.,.F.,.T.)
mreset=.T.
KEYBOARD CHR(13) && required to end prompting & switch to other menu
RETURN
PROCEDURE f_key3 && Function key F3 toggles menu horiz or vert
menu_vert=IIF(menu_vert=.T.,.F.,.T.)
mreset=.T.
KEYBOARD CHR(13) && required to end prompting & switch to other menu
RETURN
FUNCTION PROMPTNM
* menu requesting numbered choice rather than highlighted prompts
*
* Syntax: PROMPTNM(expN,expN,expN [,expL, expN])
* Assumptions: array prompts[] initialized
* Parameters:
* begrow = beginning row for menu
* begcol = beginning column for menu
* opts = number of menu options
* Optional:
* horiz = true if prompts should be displayed horizontally
* pspace = space from beginning of 1 prompt to next prompt
* (must not be zero!)
*
* Note: This version uses a GET/READ, and therefore is not as versatile
* as PROMPTER(). INKEY() could be used if prompts are less than 10.
* Also, if vertical prompts go beyond screen, pspace should be
* specified so prompts can go to another column.
PARAMETERS begrow,begcol,opts,horiz,pspace
IF TYPE("msgln")='U'
msgln=-1
ENDIF
IF TYPE("pspace")='U'
pspace=1
ENDIF
IF TYPE("horiz")='U'
horiz=.F.
ENDIF
PRIVATE m_row,m_col,mperrow,most,minkey
PRIVATE x,opt_sel,mpict
CLEAR TYPEAHEAD
** DO NUMLOCK WITH 'ON' && optional - see ASMFILES.ARC on NPN
IF horiz
mperrow=(80-begcol)/pspace
ELSE
m_col=begcol
ENDIF
FOR x=1 TO opts
IF horiz
most=x % mperrow
m_row=begrow+IIF(most=0,(x-1)/mperrow,x/mperrow)
m_col=begcol+IIF(most=0,mperrow*pspace,most*pspace)
@ m_row,m_col SAY STR(x,2)+'. '+prompts[x]
ELSE
@ begrow+(x-1)*pspace,begcol SAY STR(x,2)+'. '+prompts[x]
ENDIF
NEXT
mpict=IIF(opts<10,'9','99')
opt_sel=0
@ 23,0 SAY 'Enter Desired Selection ' GET opt_sel PICT mpict RANGE 0,opts
READ
** DO NUMLOCK WITH 'OFF' && optional - see ASMFILES.ARC on NPN
RETURN(opt_sel)
FUNCTION PROMPTER
* menu using highlighted prompts
*
* Syntax: PROMPTER(expN,expN,expN,expC,expC [,expN] [,expL] [expN])
* Assumptions: prompts[] array initialized, and
* at least first 5 parameters passed
* Parameters:
* begrow = beginning row for prompts
* begcol = beginning column for prompts
* opts = number of promts
* ncolor = normal color to use
* (cannot use Rettig's SCRATTR() if non-IBM bios)
* hcolor = color to highlight prompts
*
* Optional:
* msgln = -1 if no messages, else message line number
* if >=0, there must be a message for every prompt
* horiz = true if prompts should be displayed horizontally
* pspace = space from beginning of 1 prompt to next prompt
* (must not be zero, required if many prompts)
PARAMETERS begrow,begcol,opts,ncolor,hcolor,msgln,horiz,pspace
PRIVATE m_row,m_col,mperrow,most,x,minkey
DECLARE prmptbak[25],mesgbak[25]
** DO NUMLOCK WITH 'off' && optional - see ASMFILES.ARC on NPN
IF TYPE("msgln")='U'
msgln=-1
ENDIF
IF TYPE("horiz")='U'
horiz=.F.
ENDIF
IF TYPE("pspace")='U'
pspace=1
ENDIF
CALL CURSOR WITH 'off' && Rettig call to turn cursor off
CLEAR TYPEAHEAD
IF horiz
mperrow=(80-begcol)/pspace
ELSE
m_col=begcol
ENDIF
FOR x=1 TO opts && display choices in reverse video
IF horiz
most=x % mperrow
m_row=begrow+IIF(most=0,(x-1)/mperrow,x/mperrow)
m_col=begcol+IIF(most=0,mperrow*pspace,most*pspace)
@ m_row,m_col SAY prompts[x]
ELSE
@ begrow+(x-1)*pspace,begcol SAY prompts[x]
ENDIF
NEXT
current=1
DO WHILE .T.
IF horiz
most=current % mperrow
m_row=begrow+IIF(most=0,(current-1)/mperrow,current/mperrow)
m_col=begcol+IIF(most=0,mperrow*pspace,most*pspace)
ELSE
m_row=begrow+(current-1)*pspace
ENDIF
IF msgln<>-1
@ msgln,9 SAY messages[current]
ENDIF
SET COLOR TO &hcolor
@ m_row,m_col SAY prompts[current]
SET COLOR TO &ncolor
minkey=INKEY(0)
IF minkey<>13 && to stop screen flicker (very minor)
@ m_row,m_col SAY prompts[current] && unhighlight current selection
ENDIF
DO CASE
CASE minkey=5 && up arrow
current=IIF(current-1>=1,current-1,opts)
CASE minkey=24 && down arrow
current=IIF(current+1<=opts,current+1,1)
CASE minkey=4 .AND. horiz && right arrow
current=IIF(current<>opts,current+1,1)
CASE minkey=19 .AND. horiz && left arrow
current=IIF(current<>1,current-1,opts)
CASE minkey=18 .OR. minkey=1 && PgUp or Home
current=1
CASE minkey=3 .OR. minkey=6 && PgDn or End
current=opts
CASE minkey=27 && Escape
CALL CURSOR WITH 'ON'
RETURN(0)
CASE minkey=13 && <CR> = selection
CALL CURSOR WITH 'ON'
RETURN(current)
CASE minkey<0 .OR. minkey=28 && Function keys
fknumber=IIF(minkey=28,28,ABS(minkey)+1)
fkname='f_key'+IIF(minkey=28,'1',LTRIM(STR(fknumber,2)))
function='&fkname'
FOR i=1 TO opts && save prompts before calling
prmptbak[i]=prompts[i] && in case the function does prompts
mesgbak[i]=messages[i] && because they are global
NEXT
IF function='HELP'
** DO HELP WITH PROCNAME(),PROCLINE(),READVAR()
ELSE
IF function<>'Undefined'
DO SETFKEY WITH fknumber && turn off this function key
DO &function
DO SETFKEY WITH fknumber,function && turn back on
ENDIF
ENDIF
FOR i=1 TO opts
prompts[i]=prmptbak[i]
messages[i]=mesgbak[i]
NEXT
CALL CURSOR WITH 'OFF'
OTHERWISE && scan first letters of prompts for key hit
FOR x=1 TO opts
IF prompts[x]=UPPER(CHR(minkey))
CALL CURSOR WITH 'ON'
RETURN(x)
ENDIF
NEXT
ENDCASE
ENDDO
************* end of file **************************************************